Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue60/Alfresco/AAExpr.pas

Pascal/Delphi Source File | 2000-06-25 | 15.8 KB | 512 lines

{*********************************************************}
{* AAExpr                                                *}
{* Copyright (c) Julian M Bucknall 1998-1999             *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Expression parser and evaluator                       *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AAExpr;

{Version 1: initial release}
{Version 2: Fixed equal precedence parsing, and overread bug}

interface

uses
  SysUtils,
  AAChStk,
  AAStStk,
  AAVarLst;

type
  TaaExprTokenType = ( {Expression token types}
         ttOperator,   {..an operator}
         ttNumOperand, {..a numeric operand}
         ttVarOperand, {..an operand that's a variable}
         ttEndOfExpr); {..the end of the expression}

type
  TaaExprParserState = ( {Possible parser states}
     psCannotBeOperand,  {..the next token cannot be an operand}
     psCouldBeOperand,   {..the next token could be an operand}
     psMustBeOperand);   {..the next token must an operand or '('}

type
  TaaExpressionParser = class
    private
      FExpr     : PChar;
      FOrigExpr : PChar;
      FParsed   : boolean;
      FStStack  : TaaStringStack;
      FOpStack  : TaaCharacterStack;
      FVarList  : TaaVariableList;
    protected
      function epGetExpression : string;
      function epGetRPNExpression : string;
      function epGetValue : double;
      function epGetVariable(const aName : string) : double;
      procedure epSetExpression(aExpr : string);
      procedure epSetVariable(const aName : string; aValue : double);

      procedure epRaiseBadExpressionError(aPosn : PChar);

      procedure epCheckBadParserState(aState    : TaaExprParserState;
                                      aBadState : TaaExprParserState;
                                      aCharPos  : PChar);
      procedure epFindEndOfNumber;
      procedure epFindEndOfIdentifier;
      procedure epFormRPNSubExpr(aOp : char; aCharPos : PChar);
      function epGetNextToken(var aStartToken : PChar) : TaaExprTokenType;
      function epGetPrecedence(aOp : char) : integer;
      procedure epParseToRPN;
      procedure epPushNewOperand(aStartPos : PChar);
      procedure epSkipBlanks;

    public
      constructor Create(const aExpr : string);
      destructor Destroy; override;

      {$IFOPT D+}
      procedure TokenPrint;
      {$ENDIF}

      property Expression : string
         read epGetExpression write epSetExpression;
      property RPNExpression : string
         read epGetRPNExpression;
      property Value : double
         read epGetValue;
      property Variable[const aName : string] : double
         read epGetVariable write epSetVariable;
  end;

implementation

uses
  AAFltStk;

const
  OperatorSet = ['(', ')', '^', '*', '/', '+', '-'];
  NumberSet = ['0'..'9', '.'];
  IdentifierSet = ['A'..'Z', 'a'..'z', '0'..'9', '_'];

const
  UnaryMinus = char(ord('-') or $80);

{===Helper functions=================================================}
function Power(X, Y : double) : double;
begin
  if (Y = 0.0) then
    Result := 1.0
  else if (Y = 1.0) then
    Result := X
  else
    Result := exp(ln(X) * Y);
end;
{====================================================================}


{===TaaExpressionParser==============================================}
constructor TaaExpressionParser.Create(const aExpr : string);
begin
  inherited Create;
  {create a string stack for the operands and an operator stack}
  FStStack := TaaStringStack.Create(4096);
  FOpStack := TaaCharacterStack.Create;
  {create a variable list}
  FVarList := TaaVariableList.Create;
  {set the expression string}
  Expression := aExpr;
end;
{--------}
destructor TaaExpressionParser.Destroy;
begin
  Expression := '';
  FStStack.Free;
  FOpStack.Free;
  FVarList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaExpressionParser.epCheckBadParserState(
                                aState    : TaaExprParserState;
                                aBadState : TaaExprParserState;
                                aCharPos  : PChar);
begin
  if (aState = aBadState) then
    epRaiseBadExpressionError(aCharPos);
end;
{--------}
procedure TaaExpressionParser.epFindEndOfNumber;
var
  TempExpr : PChar;
begin
  {assume that FExpr is a digit, find the end of the stream of digits}
  TempExpr := FExpr;
  while (TempExpr^ in NumberSet) do
    inc(TempExpr);
  FExpr := TempExpr;
end;
{--------}
procedure TaaExpressionParser.epFindEndOfIdentifier;
var
  TempExpr : PChar;
begin
  {assume that FExpr is an alphanum char, find the end of the stream
   of alphanum chars}
  TempExpr := FExpr;
  while (TempExpr^ in IdentifierSet) do
    inc(TempExpr);
  FExpr := TempExpr;
end;
{--------}
procedure TaaExpressionParser.epFormRPNSubExpr(aOp      : char;
                                               aCharPos : PChar);
var
  PrecOp   : integer;
  PrecTop  : integer;
  TempOp   : char;
  Operand1 : string[255];
  Operand2 : string[255];
begin
  {this routine is called when the operator about to be pushed, aOp,
   has a precedence lower than or equal to the operator on top of the
   operator stack. We need to pop off some operators and operands and
   form some RPN expressions to push onto the operand stack, until the
   operator stack is exhausted or the top operator has a precedence
   value less than the given operator's precedence value.}
  PrecOp := epGetPrecedence(aOp);
  PrecTop := epGetPrecedence(FOpStack.Examine);
  while (PrecOp <= PrecTop) and (PrecTop > 1) do begin
    TempOp := FOpStack.Pop;
    if (TempOp = UnaryMinus) then begin
      if (FStStack.Count = 0) then
        epRaiseBadExpressionError(aCharPos);
      Operand1 := FStStack.Pop + UnaryMinus;
      FStStack.Push(Operand1);
    end
    else begin
      if (FStStack.Count < 2) then
        epRaiseBadExpressionError(aCharPos);
      Operand2 := FStStack.Pop;
      Operand1 := FStStack.Pop + Operand2 + TempOp;
      FStStack.Push(Operand1);
    end;
    if FOpStack.IsEmpty then
      PrecOp := 0
    else
      PrecTop := epGetPrecedence(FOpStack.Examine);
  end;
  {if the given operator was a right parenthesis the top of the
   operator stack *must* be a left parenthesis and we should remove
   it}
  if (aOp = ')') then begin
    if FOpStack.IsEmpty or (FOpStack.Examine <> '(') then
      epRaiseBadExpressionError(aCharPos);
    FOpStack.Pop;
  end;
end;
{--------}
function TaaExpressionParser.epGetExpression : string;
begin
  Result := StrPas(FOrigExpr);
end;
{--------}
function TaaExpressionParser.epGetNextToken(var aStartToken : PChar)
                                                   : TaaExprTokenType;
var
  CurChar : char;
begin
  epSkipBlanks;
  aStartToken := FExpr;
  CurChar := aStartToken^;
  if (CurChar = #0) then
    Result := ttEndOfExpr
  else if (CurChar in OperatorSet) then begin
    inc(FExpr); {operators are always one character in size}
    Result := ttOperator;
  end
  else if (CurChar in NumberSet) then begin
    epFindEndOfNumber;
    Result := ttNumOperand;
  end
  else if (CurChar in IdentifierSet) then begin
    epFindEndOfIdentifier;
    Result := ttVarOperand;
  end
  else begin
    Result := ttEndOfExpr;
    epRaiseBadExpressionError(aStartToken);
  end;
end;
{--------}
function TaaExpressionParser.epGetPrecedence(aOp : char) : integer;
const
  Operators : string[8] = '()^*/+-' + UnaryMinus;
  Precedences : array [1..8] of byte = (1,1,7,5,5,3,3,9);
var
  Posn : integer;
begin
  Posn := Pos(aOp, Operators);
  Result := Precedences[Posn];
end;
{--------}
function TaaExpressionParser.epGetRPNExpression : string;
begin
  if not FParsed then
    epParseToRPN;
  Result := FStStack.Examine;
end;
{--------}
function TaaExpressionParser.epGetValue : double;
var
  DblStack : TaaFloatStack;
  i        : integer;
  Operand1 : double;
  Operand2 : double;
  Expr     : string[255];
  OperandSt: string[255];
begin
  if not FParsed then
    epParseToRPN;
  {prepare a stack for doubles}
  DblStack := TaaFloatStack.Create;
  try
    {read through the RPN expression and evaluate it}
    Expr := FStStack.Examine;
    i := 0;
    while (i < length(Expr)) do begin
      inc(i);
      if (Expr[i] = ' ') then begin
        if (Expr[i+1] in NumberSet) then begin
          OperandSt := '';
          while (i < length(Expr)) and
                (Expr[i+1] in NumberSet) do begin
            OperandSt := OperandSt + Expr[i+1];
            inc(i);
          end;
          DblStack.Push(StrToFloat(OperandSt));
        end
        else begin
          OperandSt := '';
          while (i < length(Expr)) and
                (Expr[i+1] in IdentifierSet) do begin
            OperandSt := OperandSt + Expr[i+1];
            inc(i);
          end;
          DblStack.Push(FVarList.Value[OperandSt]);
        end
      end
      else begin
        if Expr[i] = UnaryMinus then
          DblStack.Push(-DblStack.Pop)
        else begin
          Operand2 := DblStack.Pop;
          Operand1 := DblStack.Pop;
          case Expr[i] of
            '+' : DblStack.Push(Operand1 + Operand2);
            '-' : DblStack.Push(Operand1 - Operand2);
            '*' : DblStack.Push(Operand1 * Operand2);
            '/' : DblStack.Push(Operand1 / Operand2);
            '^' : DblStack.Push(Power(Operand1, Operand2));
          end;{case}
        end;
      end;
    end;
    Result := DblStack.Pop;
  finally
    DblStack.Free;
  end;
end;
{--------}
function TaaExpressionParser.epGetVariable(const aName : string) : double;
begin
  Result := FVarList.Value[aName];
end;
{--------}
procedure TaaExpressionParser.epParseToRPN;
var
  ParserState : TaaExprParserState;
  TokenType   : TaaExprTokenType;
  Op          : char;
  StartPos    : PChar;
  PrecOp      : integer;
  PrecTop     : integer;
begin
  {if we've done this already, get out}
  if FParsed then
    Exit;
  {initialise the operator stack to have a left parenthesis; when we
   reach the end of the expression we'll be pretending it has a right
   parenthesis}
  FOpStack.Clear;
  FOpStack.Push('(');
  {initialise the operand stack}
  FStStack.Clear;
  {initialise the parser}
  FExpr := FOrigExpr;
  ParserState := psCouldBeOperand;
  {get the next token from the expression}
  TokenType := epGetNextToken(StartPos);
  {process all the tokens}
  while (TokenType <> ttEndOfExpr) do begin
    {what type of token are we trying to parse?}
    case TokenType of
      ttOperator :
        begin
          {it's an operator}
          Op := StartPos^;
          {if the operator is a left parenthesis, just push it onto
           the operator stack}
          if (Op = '(') then begin
            FOpStack.Push(Op);
            ParserState := psCouldBeOperand;
          end
          else begin
            epCheckBadParserState(ParserState, psMustBeOperand, StartPos);
            {if the operator is a right parenthesis, start popping off
             operators and operands and forming RPN subexpressions,
             until we reach a left parenthesis}
            if (Op = ')') then begin
              if FOpStack.IsEmpty then
                epRaiseBadExpressionError(StartPos);
              epFormRPNSubExpr(')', StartPos);
              ParserState := psCannotBeOperand;
            end
            {if the operator is a unary operator, then ignore a unary
             plus (it has no effect) and push a unary minus}
            else if (ParserState = psCouldBeOperand) then begin
              if (Op <> '+') and (Op <> '-') then
                epRaiseBadExpressionError(StartPos);
              if (Op = '-') then
                FOpStack.Push(UnaryMinus);
              ParserState := psMustBeOperand;
            end
            {if we reach this point, the operator must be pushed onto
             the stack, however, we first need to check that we are
             not pushing it onto an operator of greater or equal
             precedence}
            else begin
              PrecOp := epGetPrecedence(Op);
              if FOpStack.IsEmpty then
                PrecTop := 0
              else
                PrecTop := epGetPrecedence(FOpStack.Examine);
              if (PrecOp <= PrecTop) then
                epFormRPNSubExpr(Op, StartPos);
              FOpStack.Push(Op);
              ParserState := psCouldBeOperand;
            end;
          end;
        end;
      ttNumOperand,
      ttVarOperand :
        begin
          {it's an operand}
          epCheckBadParserState(ParserState, psCannotBeOperand, StartPos);
          epPushNewOperand(StartPos);
          ParserState := psCannotBeOperand;
        end;
    end;
    {get the next token from the expression}
    TokenType := epGetNextToken(StartPos);
  end;
  {at the end we pretend that the expression was terminated with a
   right parenthesis and we can't be expecting an operand}
  epCheckBadParserState(ParserState, psMustBeOperand, StartPos);
  epFormRPNSubExpr(')', StartPos);
  {at this point, the operator stack should be empty and the operand
   stack should have one item: the RPN of the original expression}
  if (not FOpStack.IsEmpty) or (FStStack.Count <> 1) then
    epRaiseBadExpressionError(StartPos);
  FParsed := true;
end;
{--------}
procedure TaaExpressionParser.epPushNewOperand(aStartPos : PChar);
var
  TempStr : string[255];
begin
  TempStr[0] := char(succ(FExpr - aStartPos));
  TempStr[1] := ' ';
  Move(aStartPos^, TempStr[2], FExpr - aStartPos);
  FStStack.Push(TempStr);
end;
{--------}
procedure TaaExpressionParser.epRaiseBadExpressionError(aPosn : PChar);
begin
  if (aPosn = StrEnd(FOrigExpr)) then
    raise Exception.Create(
       'Badly formed expression detected at end of string')
  else
    raise Exception.Create(
       Format('Badly formed expression with character [%s], at position %d',
              [aPosn^, succ(aPosn - FOrigExpr)]));
end;
{--------}
procedure TaaExpressionParser.epSetExpression(aExpr : string);
begin
  {first destroy the original expression}
  if (FOrigExpr <> nil) then
    StrDispose(FOrigExpr);
  {now allocate the new one}
  if (aExpr = '') then
    FOrigExpr := nil
  else begin
    if (length(aExpr) > 255) then
      raise Exception.Create('TaaExpressionParser: the expression is too long');
    FOrigExpr := StrAlloc(succ(length(aExpr)));
    StrPCopy(FOrigExpr, aExpr);
  end;
  {the expression is not yet parsed}
  FParsed := aExpr = '';
end;
{--------}
procedure TaaExpressionParser.epSetVariable(const aName : string; aValue : double);
begin
  FVarList.Value[aName] := aValue
end;
{--------}
procedure TaaExpressionParser.epSkipBlanks;
var
  TempExpr : PChar;
begin
  {jump past all the blanks}
  TempExpr := FExpr;
  while (TempExpr^ = ' ') do
    inc(TempExpr);
  FExpr := TempExpr;
end;
{--------}
{$IFOPT D+}
procedure TaaExpressionParser.TokenPrint;
var
  i         : integer;
  StartPos  : PChar;
  TokenType : TaaExprTokenType;
begin
  FExpr := FOrigExpr;
  TokenType := epGetNextToken(StartPos);
  while TokenType <> ttEndOfExpr do begin
    case TokenType of
      ttOperator   : write('  operator:         ');
      ttNumOperand : write('  number operand:   ');
      ttVarOperand : write('  variable operand: ');
    end;{case}
    for i := 0 to pred(FExpr-StartPos) do
      write((StartPos + i)^);
    writeln;
    TokenType := epGetNextToken(StartPos);
  end;
  writeln('  end of expression');
end;
{$ENDIF}
{====================================================================}

end.